(library (grid-gen code)

(export self-cont
	arr-loop
        arr-loop-d
        arr-loop-in
        arr-loop-in-d
        nop
        beg
        main-p
        set-val
        map-ex
        exp-ex
        exp-code
        evl
        cur-ptr
        orig-ptr
        raw
        save-txt
        save-txt-in
        to-file
        print
        fprint
        fwrite
        do-while
        do-loop
        do-loop-d
        do-loop-in-d
        do-loop-in
        do-loop-bnd
        exp-sv
        exp-sv-local
        make-exp-sv
        omp-do
        omp-reduce
        omp-locals
        do-every
        measure-time
        call
        
        timer-tick
        code:global-timer
        code:zero-tim
        time:get-sec
        code:get-sec
        
        cur-pass
        add-wrapper
        rm-wrapper
        code-wrappers
        apply-wrappers
        code:pass-all
        force-code
        
        add-include
        includes
        
        set-ptr
        
        is-op?
        is-fn?
        is-nop?
        is-ptr?
        is-orig-ptr?
        is-set-val?
        is-if?
        
        exp-v-def
)

(import (guile)
        (rnrs)
        (grid-gen main)
        (grid-gen vars)
)

(define locals (list))

(define self-cont-list 
       '(CUR_PTR ORIG_PTR
         CODE_LOOP CODE_BEGIN CODE_MAINP
         CODE_PRINT CODE_FWRITE CODE_FPRINT CODE_WHILE
         OMP_REDUCE OMP_DO OMP_LOCALS LOOP_PRE_CODE LOOP_CODE LOOP_PRE_NONE
         CODE_EVAL CODE_TO_FILE SET_VAL CODE_NOP + - * / ** = > RAW RUN_CODE
         CODE_CALL CODE_EVERY CODE_MEASURE_TIME
         >= < <= sin asin cos acos tan atan omp_get_wtime
         exp log sqrt int sign abs min max and or isnan time floor ceil
         real
         not IND_IN PTR_IN EXP_SV
         M_ARR M_DIM
        )
)

(define protected-exprs
  '(LOOP_DIMS LOOP_SEQ SET_PTR OMP_FUNC)
)

;(define-syntax self-cont
;  (lambda (x)
;    (syntax-case x ()
;      ((_ v) (datum->syntax
;               (syntax k)
;               `(begin 
;                 ;(define-public
;                 ;    ,(syntax->datum (syntax v)) 
;                 ;     (lambda args 
;                 ;             (cons (quote ,(syntax->datum (syntax v)))
;                 ;                   args
;                 ;             )
;                 ;     )
;                 ;)
;                  (set! self-cont-list 
;                        (cons (quote ,(syntax->datum (syntax v)))
;                               self-cont-list
;                        )
;                  )
;                )
;             )
;      )
;    )
;  )
;)

(define self-cont (lambda (x)
  (set! self-cont-list (cons x self-cont-list))
))


(define is-op? (lambda (e)
  (and (list? e)
       (not (null? e))
       (let ((op (car e)))
         (or
           (eq? op '+)
           (eq? op '-)
           (eq? op '*)
           (eq? op '/)
           (eq? op '**)
           (eq? op '=)
           (eq? op '>)
           (eq? op '>=)
           (eq? op '<)
           (eq? op '<=)
         )
       )
  )
))

(define is-fn? (lambda (e)
  (and (list? e)
       (not (null? e))
       (let ((fn (car e)))
         (or
           (eq? fn 'sin)
           (eq? fn 'asin)
           (eq? fn 'cos)
           (eq? fn 'acos)
           (eq? fn 'tan)
           (eq? fn 'atan)
           (eq? fn 'exp)
           (eq? fn 'log)
           (eq? fn 'sqrt)
           (eq? fn 'floor)
           (eq? fn 'ceil)
           (eq? fn 'int)
           (eq? fn 'sign)
           (eq? fn 'epsilon)
           (eq? fn 'abs)
           (eq? fn 'max)
           (eq? fn 'min)
           (eq? fn 'and)
           (eq? fn 'not)
           (eq? fn 'or)
           (eq? fn 'if)
           (eq? fn 'IND_IN)
           (eq? fn 'PTR_IN)
           (eq? fn 'isnan)
           (eq? fn 'time)
           (eq? fn 'real)
           (eq? fn 'omp_get_wtime)
         )
       )
  )
))


(define do-loop-bnd-d (lambda (dims dms . exprs)
 `(CODE_LOOP (LOOP_DIMS ,dims) (LOOP_SEQ ,dms) (LOOP_CODE ,(apply beg exprs)))
))

(define do-loop-bnd (lambda (dims . exprs)
  (apply do-loop-bnd-d (append (list dims (iota1 (length dims))) exprs))
))

(define do-loop-in-d (lambda (dims o dms . exprs)
  (apply do-loop-bnd-d
         (append (list (map (lambda (x) `((+ ,o 1) (- ,x ,o))) dims)
                       dms
                 )
                 exprs
         )
  )
))

(define do-loop-d (lambda (dims dms . exprs)
  (apply do-loop-in-d
         (append (list dims
                       0
                       dms
                 )
                 exprs
         )
  )
))

(define do-loop-in (lambda (dims o . exprs)
  (apply do-loop-in-d
         (append (list dims
                       o
                       (iota1 (length dims))
                 )
                 exprs
         )
  )
))

(define do-loop (lambda (dims . exprs)
  (apply do-loop-in-d
         (append (list dims
                       0
                       (iota1 (length dims))
                 )
                 exprs
         )
  )
))

(define arr-loop-in-d (lambda (array o dms . exprs)
   (if (var-has-dims? array)
     (apply do-loop-in-d (append (list (var-dims array) o dms) exprs))
     (int-err "Error: arr-loop must be used with array! (~a)\n" (array 'name))
   )
))

(define arr-loop-in (lambda (array o . exprs)
  (apply arr-loop-in-d
         (append (list array o (iota1 (length (var-dims array))))
                 exprs
         )
  )
))

(define arr-loop (lambda (array . exprs)
  (apply arr-loop-in (append (list array 0) exprs))
))

(define arr-loop-d (lambda (array dms . exprs)
  (apply arr-loop-in-d (append (list array 0 dms) exprs))
))


(define nop (list 'CODE_NOP))

(define is-nop? (lambda (e)
  (and (list? e) (not (null? e)) (eq? (car e) 'CODE_NOP))
))

(define beg (lambda b 
  (cons 'CODE_BEGIN b)
))

(define main-p (lambda b 
  (cons 'CODE_MAINP b)
))

(define raw (lambda (s) 
  (list 'RAW s)
))

(define do-every (lambda (n u . cod)
 `(CODE_EVERY ,n ,u ,cod)
))

(define measure-time (lambda (v . cod)
 `(CODE_MEASURE_TIME ,v ,cod)
))

(define evl (lambda b 
  (cons 'CODE_EVAL b)
))

(define do-while (lambda (ex . exs)
  (list 'CODE_WHILE ex exs)
))

(define to-file (lambda (fname . bls)
  (letrec* ((exflg (lambda (l)
                     (if (or (eq? (car l) 'bin)
                             (eq? (car l) 'append)
                             (eq? (car l) 'main)
                             (eq? (car l) 'new)
                             (eq? (car l) 'replace)
                         )
                         (let ((r (exflg (cdr l))))
                          `(,(cons (car l) (car r)) ,(cadr r))
                         )
                        `(() ,l)
                     )
                   ))
            (flb (exflg bls))
           )
    (list 'CODE_TO_FILE fname (car flb) #f (cadr flb))
  )
))

(define print (lambda bls
  (cons 'CODE_PRINT bls)
))

(define fprint (lambda bls
  (cons 'CODE_FPRINT bls)
))

(define fwrite (lambda bls
  (cons 'CODE_FWRITE bls)
))

(define call (lambda (name . args)
  (list 'CODE_CALL name args)
))

(define exp-code (lambda (l)
  (map exp-ex l)
))

(define exp-let (lambda (ops)
  (let ((old-loc locals))
    (set! locals (append (car ops) locals))
    (let ((res (cons 'CODE_BEGIN (map exp-ex (cdr ops)))))
      (set! locals old-loc)
      res
    )
  )
))

(define is-in-decl? (lambda (d l)
  (if (null? l)
      #f
      (or (eq? d (caar l))
          (is-in-decl? d (cdr l))
      )
  )
))

(define map-ex (lambda (f ex)
  (cond ((or (is-op? ex) (is-fn? ex))
         (cons (car ex)
               (map (lambda (e) (map-ex f e)) (cdr ex))
         )
        )
        ((and (is-var? ex) (var-has-ind? ex))
         (f (set-ind (del-ind ex)
                     (map (lambda (e) (map-ex f e)) (var-ind ex))
            )
         )
        )
        (#t (f ex))
  )
))

(define get-from-decl (lambda (d l)
  (if (not (null? l))
      (if (eq? d (caar l))
        (cadar l)
        (get-from-decl d (cdr l))
      )
  )
))

(define exp-locals (lambda (e)
  (cond ((symbol? e) 
         (if (is-in-decl? e locals)
             (exp-locals (get-from-decl e locals))
             e
         )
        )
        ((and (list? e) (not (null? e)))
         (if (or (eq? (car e) 'quote) (eq? (car e) 'quasiquote))
             e
             (cons (exp-locals (car e)) (exp-locals (cdr e)))
         )
        )
        (#t e)
  )
))

(define exp-ex (lambda (eee)
  (let ((e (exp-locals eee)))
;;    (format #t "EE: ~a\n" e)
    (cond ((number? e) e)
          ((string? e) e)
          ((symbol? e) 
            (if (is-in-decl? e locals)
              (exp-ex (get-from-decl e locals))
              (begin
;;              (format #t "EV2 ~a\n" e)
              (primitive-eval e)
              ;;(compile e)
              )
            )
          )
          ((is-var? e) e)
          ((procedure? e) e)
          ((is-ptr? e) e)
          ((and (list? e) (not (null? e)))
            (let ((op (car e))
                  (vals (cdr e))
                 )
              (cond 
                    ((eq? op 'if) (let ((vls (map exp-ex vals)))
                                       (cons 'if
                                             (if (> (length vls) 2)
                                                 vls
                                                 (append vls (list (list)))
                                             )
                                       )
                                  )
                    )
                    ((eq? op 'define) (begin 
                           (primitive-eval e)
                          ;; (compile e)
                       nop))
                    ((eq? op 'let) (exp-let vals))
                    ((eq? op 'let*) (exp-let vals))
                    ((eq? op 'letrec) (exp-let vals))
                    ((eq? op 'quote) (cadr e))
                    ((eq? op 'lambda) 
                      ;;(compile e)
                      (primitive-eval e)
                    )
                    ((eq? op 'evl)
                     (format #t "EVAL: ~a\n" vals)
                     (cons 'CODE_BEGIN (map exp-ex vals))
                    )
                    ((eq? op 'beg) (cons 'CODE_BEGIN (map exp-ex vals)))
                    ((in-list? op protected-exprs ) e)
                    ((in-list? op self-cont-list) (cons op (map exp-ex vals)))
                    (#t (let ((ep (exp-ex op)))
                          (if (not (procedure? ep))
                            (format #t "EV1 ~a\nARGS: ~a\n" op vals)
                          )
                          (apply ep
                               (map exp-ex vals)
                          )
                        )
                    )
              )
            )
          )
          (#t (format #t "EX: ~a\n" e)
              (int-err "Invalid expr2")
          )
    )
  )
))

(define cur-ptr (lambda ni 
  (if (null? ni)
      'CUR_PTR
      (cons 'CUR_PTR ni)
  )
))

(define orig-ptr (lambda ni 
  (if (null? ni)
      'ORIG_PTR
      (cons 'ORIG_PTR ni)
  )
))

(define set-ptr (lambda (p)
  (list 'SET_PTR p)
))

(define is-ptr? (lambda (v)
  (and (list? v)
       (not (null? v))
       (or (eq? (car v) 'CUR_PTR)
           (eq? (car v) 'ORIG_PTR)
       )
  )
))

(define is-orig-ptr? (lambda (v)
  (and (list? v)
       (not (null? v))
       (eq? (car v) 'ORIG_PTR)
  )
))

 ;;(define-syntax set-val
 ;;  (syntax-rules ()
 ;;    ((_ v ex) (list 'SET_VAL v (quasiquote ex)))
 ;;  )
 ;;)

(define set-val (lambda (v ex)
 ;;  (list 'SET_VAL v (exp-ex ex))
  (list 'SET_VAL v ex)
))

(define code:global-timer (comp-float "global_timer"))
(define code:zero-tim (comp-float "zero_time"))

(define code:get-sec (lambda (v)
  (call "cpu_time" v)
))

(define time:get-sec code:get-sec)

(define timer-tick (lambda ()
  (time:get-sec code:global-timer)
))

(define exp-sv (lambda cod
  (cons 'EXP_SV cod)
))

;(define exp-sv-local (lambda cod
;  (cons 'EXP_SV_LOCAL cod)
;))

(define omp-do (lambda cod
  (cons 'OMP_DO cod)
))

(define omp-locals (lambda cod
  (cons 'OMP_LOCALS cod)
))

(define omp-reduce (lambda (p v)
  `(OMP_REDUCE (OMP_FUNC ,p) ,v)
))

(define is-set-val? (lambda (e)
 ;; (format #t "ISV: ~a\n" e)
  (and (list? e) (not (null? e)) (eq? (car e) 'SET_VAL))
))

(define is-if? (lambda (b)
  (and (list? b) (= (length b) 4) (eq? (car b) 'if))
))


(define includes '())

(define add-include (lambda (f)
  (set! includes (cons f includes))
))

(define passes '(1))

(define code-wrappers (make-hash-table))

(define add-wrapper (lambda (p k w)
  (let* ((key (list p k))
         (ow (hash-ref code-wrappers key #f))
         (pass1 (if (number? p)
                    (sort (remove-duplicates (cons p passes)) <)
                    (if (eq? p '*)
                        passes
                        (int-err "Invalid pass: ~a\n" p)
                    )
                )
         )
        )
    (set! passes pass1)
    (if (and ow (not (eq? ow w)))
        (int-err "Wrapper already added for this pass: ~a ~a\n" p k)
        (hash-set! code-wrappers key w)
    )
  )
))

(define rm-wrapper (lambda (p k w)
  (let* ((key (list p k))
         (ow (hash-ref code-wrappers key #f))
        )
    (if (eq? w ow)
        (hash-remove! code-wrappers key)
        ;;(int-err "Cannot remove wrapper: not found.")
    )
  )
))

(define cur-pass #f)

(define apply-wrappers (lambda (l)
  (delay
    (if (and (list? l) (not (null? l)))
        (let* ((w1 (hash-ref code-wrappers (list '* (car l))))
               (w2 (hash-ref code-wrappers (list cur-pass (car l))))
               (l1 (if w1 (w1 l) l))
               (l2 (if w2 (w2 l1) l1))
              )
          l2
        )
        l
    )
  )
))

(define force-code (lambda (cod)
  (cond ((promise? cod) (force-code (force cod)))
        ((list? cod) (map-in-order force-code cod))
        (#t cod)
  )
))

(define code:pass-all (lambda (cod)
  (letrec* ((mkps (lambda (p cod)
              ;;;(format #t "PASS: ~a\n" p)
              (let ((op cur-pass))
                (set! cur-pass p)
                (let ((res (force-code (apply-wrappers cod))))
                  (set! cur-pass op)
                  res
                )
              )
            ))
            (mkpsl (lambda (pl cod)
              (if (null? pl)
                  cod
                  (mkpsl (cdr pl) (mkps (car pl) cod))
              )
            ))
           )
    (mkpsl passes (cons 'RUN_CODE (exp-code cod)))
  )
))

(def-cache exp-v-def (lambda (ex0 force)
  (letrec* ((evd (lambda (ex)
              (cond ((is-var? ex)
                     (if (and (or force (ex 'def-expand?)) (var-has-def? ex))
                         (evd (var-def ex))
                         (if (var-has-ind? ex)
                             (set-ind (del-ind ex)
                                      (map evd (var-ind ex))
                             )
                             ex
                         )
                     )
                    )
                    ((or (is-op? ex) (is-fn? ex))
                     (cons (car ex) (map evd (cdr ex)))
                    )
                    (#t ex)
              )
            ))
           )
    (evd ex0)
  )
))

(define wrap-begin (lambda (cod)
  (cons (car cod) (map-in-order apply-wrappers (cdr cod)))
))

(define wrap-run-code wrap-begin)

(define wrap-tick (lambda (cod)
  (cons (car cod) 
        (cons 
          (beg
            (timer-tick)
            (set-val code:zero-tim `(time))
          )
          (cdr cod)
        )
  )
))

(define wrap-omp-do wrap-begin)

(define wrap-exp-sv wrap-begin)

(define wrap-to-file (lambda (cod)
  (append (list-head cod 3)
        `(,(if (list-ref cod 3)
               (map-in-order apply-wrappers (list-ref cod 3))
               #f
           )
          ,(map-in-order apply-wrappers (list-ref cod 4))
         )
  )
))

(define wrap-every (lambda (cod)
  (list (car cod) (cadr cod) (caddr cod)
        (map-in-order apply-wrappers (cadddr cod))
  )
))

(define wrap-measure-time (lambda (cod)
  (list (car cod) (cadr cod)
        (map-in-order apply-wrappers (caddr cod))
  )
))

(define wrap-while (lambda (bl)
  `(,(car bl) ,(cadr bl) ,(map-in-order apply-wrappers (caddr bl)))
))

(define wrap-if (lambda (bl)
 `(,(car bl)
   ,(cadr bl)
   ,(apply-wrappers (caddr bl))
   ,(if (null? (cadddr bl))
        (list)
        (apply-wrappers (cadddr bl))
    )
  )
))

(define wrap-loop-pre-code (lambda (bl)
;;  (format #t "PCD: ~a\n" bl)
  (list (car bl) (cadr bl) (caddr bl) (apply-wrappers (cadddr bl)))
))

(define wrap-loop (lambda (bl)
  (let ((dms (cadr (obj-find-el bl 'LOOP_DIMS)))
        (seq (cadr (obj-find-el bl 'LOOP_SEQ)))
        (cod (cadr (obj-find-el bl 'LOOP_CODE)))
        (pcd (let ((cd (obj-find-el bl 'LOOP_PRE_CODE)))
               (if cd
                  `(,(car cd) ,(apply-wrappers (cadr cd)))
                  'LOOP_PRE_NONE
               )
             )
        )
       )
;;    (format #t "LPCOD: ~a\n" cod)
   `(CODE_LOOP (LOOP_DIMS ,dms) 
               (LOOP_SEQ  ,seq)
               ,pcd
               (LOOP_CODE ,(apply-wrappers cod))
    )
  )
))

(define tim-buf (comp-array (comp-int "itim_buf") '(8)))
)

(add-wrapper '* 'CODE_WHILE wrap-while)
(add-wrapper '* 'CODE_BEGIN wrap-begin)
(add-wrapper '* 'CODE_TO_FILE wrap-to-file)
(add-wrapper '* 'CODE_EVERY wrap-every)
(add-wrapper '* 'CODE_MEASURE_TIME wrap-measure-time)
(add-wrapper '* 'RUN_CODE wrap-run-code)
(add-wrapper '* 'if wrap-if)
(add-wrapper '* 'LOOP_PRE_CODE wrap-loop-pre-code)
(add-wrapper '* 'OMP_DO wrap-omp-do)
(add-wrapper '* 'EXP_SV wrap-exp-sv)
(add-wrapper '* 'CODE_LOOP wrap-loop)

(add-wrapper 0 'RUN_CODE wrap-tick)